Belgian Amiga Club - ADF Collection/BS1 part 47.7z/BS1 part 47/HiSoft BASIC v1.04 (1989)(HiSoft)(Disk 2 of 2)[h Band].7z/HiSoft BASIC v1.04 (1989)(HiSoft)(Disk 2 of 2)[h Band].adf/objedit.bas

BASIC Source File | 1988-12-19 | 13.3 KB | 553 lines

'     Modified : Oct 23, 1985
'     Modified : Aug 28, 1986  CAS
'     Modified : Dec 12, 1988  AMP
' changes made to AmigaBASIC version for HiSoft BASIC:
' CONSTs used, ON BREAK removed
' graphics library not used for drawing mode (COLOR used instead)
' INPUT$ used for kbd scanning instead of INKEY$
' MaxBob variables removed, MaxMem made a long integer

REM $OPTION k60
' when compiling, Event Checks *must* be On
' it is recommended that Break Checks are also On


  DEFINT a-z

'   Format of the file produced by this program
'
'   long ColorSetOffset
'   long DataSetOffset
'   long depth                  number of bit planes
'   long width                  width of object in pixels
'   long height                 height of object in pixels
'   short flags:
'     fVsprite=1                TRUE if its a vsprite, FALSE if its a BOB
CONST collisionPlaneIncluded=2  'never set by this editor
CONST imageShadowIncluded=4     'never set by this editor
CONST SAVEBACK=8                'save background before drawing BOB
CONST OVERLAY=16                'color 0 for BOB is transparent, not black
CONST SAVEBOB=32                'let BOB act like a paint brush
'   short planePick          which playfield planes do object planes map to
'   short planeOnOff         set to 0 by object editor
'   <first bit-plane>
'   <second bit-plane>       /* must begin on even byte boundary */
'     :
'   <last bit-plane>
'   <imageShadow bit-plane>  not currently produced by object editor
'   <collision bit-plane>    not currently produced by object editor
'

  DEF FNArraySize& = 3+INT((BobRight+16)/16)*(BobBottom+1)*Depth
  DIM DrawRect(3),ToolName$(6)

  scrn=-1 'puts window in workbench screen
  Depth=2
  WinY=185: WinX=617
'If BOBs are to be created with other than 2 bit-planes
' alter next 4 lines (only if machine has more than 256k)
' Depth=3
' scrn=1
' SCREEN scrn,640,200,Depth,2
' WINDOW 1,,(0,0)-(WinX,WinY),31,scrn

  PRINT "Amiga-BASIC Object Editor"
  PRINT "HiSoft BASIC version"
  GOSUB InitConstant
  GOSUB InitFile
  GOSUB InitMenu
StartOver:
  ON MENU GOSUB CheckMenu : MENU ON
  ON MOUSE GOSUB CheckMouse : MOUSE ON
  DrawBoundary
  GOSUB PrintStatus
  Unfinished = -1
  WHILE Unfinished
    SLEEP 'this program is completely event driven
  WEND

  MENU OFF: MOUSE OFF
  SCREEN CLOSE 1
  WINDOW CLOSE 1

  MENU RESET
  CLS
  END

InitConstant:
  IF FRE(-1)>50000& THEN MaxTool=6 ELSE MaxTool=5
  ToolMode=1
  CurrentColor=1
  MaxY=120: MaxX=500
  MaxY10=MaxY+10: MaxX10=MaxX+10
  StatusLine=20
  Top = 20: Left = 450
  RETURN

InitFile:
  CLS
  IF Depth = 2 THEN
    PRINT "Enter 1 if you want to edit sprites"
    INPUT "Enter 0 if you want to edit bobs > ",fVSprite
    CLS
  ELSE
    fVSprite = 0 'user can't edit sprite
  END IF
  FileName$=""
  Flags=SAVEBACK+OVERLAY+fVSprite
  IF fVSprite = 1 THEN BobRight=15 ELSE BobRight=31
  BobBottom=31
  CurrentX=BobRight:CurrentY=BobBottom
  maxColor=2^Depth - 1
  PlanePick=maxColor
  Change=0
  RETURN

InitMenu:
  MENU 1,0,1,"File"
  MENU 1,1,1,"New"
  MENU 1,2,1,"Open ..."
  MENU 1,3,1,"Save"
  MENU 1,5,1,"Quit"
  MENU 1,4,1,"Save as ..."
  MENU 2,0,1,"Tools"
  MENU 3,0,1,"Enlarge"
  MENU 3,1,1,"4x4"
  MENU 3,2,1,"1x1"
  MENU 4,0,1,""
  ToolName$(1)="Pen"
  ToolName$(2)="Line"
  ToolName$(3)="Oval"
  ToolName$(4)="Rectangle"
  ToolName$(5)="Eraser"
  ToolName$(6)="Paint"
  FOR i=1 TO MaxTool
    MENU 2,i,1,ToolName$(i)
  NEXT i
  RETURN

CheckMenu:
  MenuId=MENU(0)
  MenuItem=MENU(1)
  ON MenuId GOTO FileMenu,ToolsMenu,FatBits

CheckMouse:
  GetCurrentXY
  IF CurrentY>MaxY+10 THEN CheckColor
  IF NOT fEnlarge THEN
    IF CurrentY>BobBottom+10 OR CurrentX>BobRight+10 THEN RETURN
    IF CurrentY>=BobBottom AND CurrentX>=BobRight THEN ChangeSizePicture
    IF (CurrentY>BobBottom OR CurrentX>BobRight) THEN RETURN
  ELSE
    IF CurrentX>BobRight*Offset OR CurrentY>BobBottom*Offset THEN RETURN
  END IF
  StartY=CurrentY
  StartX=CurrentX
  Change=-1
  ON ToolMode GOSUB Pen,DrawLine,DrawCircle,DrawRectangle,ErasePicture,PaintPicture
  RETURN

DrawLine:
  WHILE MOUSE(0)<>0
    GetCurrentXY
    IF InsideBob THEN
      InvertVideo
      LINE (StartX,StartY)-(CurrentX,CurrentY) 'draw line
      LINE (StartX,StartY)-(CurrentX,CurrentY) 'erase line
      NormalVideo
    END IF
  WEND
  LINE (StartX,StartY)-(CurrentX,CurrentY),CurrentColor
  RETURN

FatBits:
  ON MenuItem GOTO Enlarge, Shrink

Enlarge:
  IF fEnlarge THEN RETURN
  fBig = -1
  IF BobBottom > 31 THEN
    LOCATE 17,1:PRINT "Y >= 31 too large to enlarge. ";
  ELSEIF BobRight >=100 THEN
    LOCATE 17,1:PRINT "X >=100 too large to enlarge. ";
  ELSE
    fBig = 0
  END IF
  IF fBig THEN
    PRINT "Press any key to continue";
    a$=INPUT$(1)
    LOCATE 17,1:PRINT "                                  ";
    PRINT "                            ";
    RETURN
  END IF
  Offset = 4:OffsetB=Offset-1
  ChangeToolsMode 0 'Disable Tools
  MenuItem = 1
  GOSUB ToolsMenu
  fEnlarge = -1 'Enlarge flag

  DIM BobArray(FNArraySize&)
  GET (0,0)-(BobRight,BobBottom),BobArray
  LINE (Left-1,Top-1)-(Left+BobRight+1,Top+BobBottom+1),,b
  PUT (Left,Top),BobArray
  ERASE BobArray

  LINE (0,0)-(BobRight*2,BobBottom*2),0,bf
  LINE (-1,-1)-((BobRight+1)*Offset,(BobBottom+1)*Offset),,b
  m=0:n=0
  FOR i=Left TO Left+BobRight
    n=0
    FOR j=Top TO Top+BobBottom
      x=POINT(i,j)
      IF x>0 THEN LINE (m,n)-(m+OffsetB,n+OffsetB),x,bf
      n=n+Offset
    NEXT j
    m=m+Offset
  NEXT i
  RETURN


Shrink:
  IF fEnlarge = 0 THEN RETURN
  ChangeToolsMode 1
  fEnlarge = 0
  DIM BobArray(FNArraySize&)
  GET (Left,Top)-(Left+BobRight,Top+BobBottom),BobArray
  LINE (Left-1,Top-1)-(Left+BobRight+1,Top+BobBottom+1),0,bf
  LINE (0,0)-(BobRight*Offset+Offset,Offset*BobBottom+Offset),0,bf
  DrawBoundary
  PUT (0,0),BobArray
  ERASE BobArray
  RETURN


SUB ChangeToolsMode (Mode) STATIC
SHARED MaxTool
  FOR i=2 TO MaxTool
    MENU 2,i,Mode
  NEXT
END SUB

Pen:
  IF fEnlarge THEN GOTO BigPen
  GetCurrentXY
  IF InsideBob THEN PSET (CurrentX,CurrentY),CurrentColor
  WHILE MOUSE(0)<>0
    GetCurrentXY
    IF NOT InsideBob THEN RETURN
    LINE -(CurrentX,CurrentY),CurrentColor
  WEND
  RETURN

BigPen:
  GOSUB GetX1Y1
  IF InsideBob THEN
    PSET (CurrentX+Left,CurrentY+Top),CurrentColor
    LINE (x1,y1)-(x1+OffsetB,y1+OffsetB),CurrentColor,bf
  END IF
  WHILE MOUSE(0)<>0
    GOSUB GetX1Y1
    IF InsideBob  THEN
      PSET (CurrentX+Left,CurrentY+Top),CurrentColor
      LINE (x1,y1)-(x1+OffsetB,y1+OffsetB),CurrentColor,bf
    END IF
  WEND
  RETURN

GetX1Y1:
  GetCurrentXY
  IF (CurrentX>=0 AND CurrentX < (BobRight+1)*Offset) AND (CurrentY>=0 AND CurrentY <(BobBottom+1)*Offset) THEN
    InsideBob = -1
    CurrentX = INT(CurrentX/Offset)
    x1=CurrentX*Offset
    CurrentY=INT(CurrentY/Offset)
    y1=CurrentY*Offset
  ELSE
    InsideBob = 0
  END IF
  RETURN

DrawCircle:
  GOSUB TrackRect
  CenterX=(DrawRect(1)+DrawRect(3))/2
  CenterY=(DrawRect(2)+DrawRect(0))/2
  RadiusX=(DrawRect(3)-DrawRect(1))/2
  RadiusY=(DrawRect(2)-DrawRect(0))/2
  IF RadiusX=0 OR RadiusY=0 THEN RETURN
  Aspect!=ABS(RadiusY/RadiusX)
  IF RadiusX < RadiusY THEN RadiusX=RadiusY
  CIRCLE (CenterX,CenterY),RadiusX,CurrentColor,,,Aspect!
  RETURN

DrawRectangle:
  GOSUB TrackRect
  LINE (DrawRect(1),DrawRect(0))-(DrawRect(3),DrawRect(2)),CurrentColor,b
  RETURN

ErasePicture:
  WHILE MOUSE(0)<>0
    GetCurrentXY
    IF CurrentX-5<0 OR CurrentY-3<0 THEN InsideBob=0
    IF InsideBob THEN
      LINE (CurrentX-5,CurrentY-3)-(CurrentX,CurrentY),1,bf
      LINE (CurrentX-5,CurrentY-3)-(CurrentX,CurrentY),0,bf
    END IF
  WEND
  DrawBoundary
  RETURN

PaintPicture:
  IF InsideBob THEN
     LINE(0,BobBottom+1)-(BobRight+1,BobBottom+1),CurrentColor
     LINE(BobRight+1,0)-(BobRight+1,BobBottom+1),CurrentColor
     PAINT (CurrentX, CurrentY),CurrentColor
     DrawBoundary
  END IF
  RETURN

TrackRect:
  WHILE MOUSE(0)<>0
    GetCurrentXY
    IF InsideBob THEN
      DrawRect(0)=StartY
      DrawRect(1)=StartX
      DrawRect(2)=CurrentY
      DrawRect(3)=CurrentX
      InvertVideo
      FrameRect DrawRect() 'Draw it
      FrameRect DrawRect() 'Erase it
      NormalVideo
    END IF
  WEND
  IF CurrentY<StartY THEN DrawRect(0)=CurrentY: DrawRect(2)=StartY
  IF CurrentX<StartX THEN DrawRect(1)=CurrentX: DrawRect(3)=StartX
  RETURN

ChangeSizePicture:
  MaxMem& = .8 * FRE(0)
  COLOR 0
  DrawBoundary
  COLOR 1
  InvertVideo
  WHILE MOUSE(0)<>0
    GetCurrentXY
    IF (CurrentY < MaxY) AND (CurrentY > 0) THEN
     IF (CurrentX <= MaxX) AND (CurrentX >= 10) THEN
      IF MaxMem& > (1&*Depth * CurrentX * CurrentY /8) THEN
        IF fVSprite = 1 THEN BobRight = 15:CurrentX=15:ELSE BobRight=CurrentX
        BobBottom=CurrentY
        DrawBoundary
        DrawBoundary
      END IF
     END IF
    END IF
  WEND
  NormalVideo
  GOSUB GetPicture
  GOSUB RedrawPicture
  RETURN

ToolsMenu:
  ToolMode=MenuItem
  GOSUB PrintToolStatus
  RETURN

FileMenu:
  ON MenuItem GOSUB NewFile,OpenFile,SaveFile,SaveFileAs,Quit
  RETURN

NewFile:
  GOSUB CheckSave
  IF CancelCommand THEN RETURN
  CLS
  GOSUB InitFile
  GOTO StartOver

OpenFile:
  GOSUB CheckSave
  IF CancelCommand THEN RETURN
  CLS
  INPUT "Enter Filename > ",FileName$
  IF FileName$="" THEN NewFile
  OPEN FileName$ FOR INPUT AS 1
  ColorSet=CVL(INPUT$(4,1))
  DataSet=CVL(INPUT$(4,1))
  Depth=CVL(INPUT$(4,1))
  BobRight=CVL(INPUT$(4,1)) - 1
  BobBottom=CVL(INPUT$(4,1)) - 1
  REM --- UNDONE if ColorSet<>0 or DataSet<>0, read image.editor format file
  Flags=CVI(INPUT$(2,1))
  IF Flags AND 1 THEN fVSprite = 1 ELSE fVSprite = 0
  IF PlanePick <> CVI(INPUT$(2,1)) THEN
    PRINT "Error: file not compatible with this SCREEN"
  ELSE
    PlaneOnOff=CVI(INPUT$(2,1))
    ArraySize&=FNArraySize&
    DIM BobArray(ArraySize&)
    BobArray(0)=BobRight + 1
    BobArray(1)=BobBottom + 1
    BobArray(2)=Depth
    FOR i=3 TO ArraySize&-1
      BobArray(i)=CVI(INPUT$(2,1))
    NEXT i
    CLS
    CurrentX=BobRight: CurrentY=BobBottom
    GOSUB RedrawPicture
  END IF
  CLOSE #1
  Change=0
  GOTO StartOver

SaveFileAs:
  FileName$=""
SaveFile:
  IF fEnlarge THEN GOSUB Shrink
  GOSUB GetPicture
  IF FileName$="" THEN CLS: INPUT "Enter Filename > ",FileName$
  IF FileName$<>"" THEN
    OPEN FileName$ FOR OUTPUT AS 1
    PRINT #1, MKL$(0); 'ColorSet
    PRINT #1, MKL$(0); 'DataSet
    PRINT #1, MKI$(0);MKI$(BobArray(2)); 'depth
    PRINT #1, MKI$(0);MKI$(BobArray(0)); 'width
    PRINT #1, MKI$(0);MKI$(BobArray(1)); 'height
    PRINT #1, MKI$(Flags);
    PRINT #1, MKI$(PlanePick);  'planePick
    PRINT #1, MKI$(0);  'planeOnOff
    FOR i=3 TO ArraySize&-1
      PRINT #1, MKI$(BobArray(i));
    NEXT i
    IF fVSprite THEN
    'Output the colors for sprite> Change output values for different colors
      PRINT #1,MKI$(&HFF); 'White. Color 1
      PRINT #1,MKI$(0); 'Black. Color 2
      PRINT #1,MKI$(&HF80); 'Orange. Color 3
    END IF
    CLOSE#1
  END IF
  GOSUB RedrawPicture
  Change=0
  RETURN

Quit:
  Cancel=0
  GOSUB CheckSave
  IF CancelCommand THEN RETURN
  Unfinished=0
  RETURN

GetPicture:
  ArraySize&=FNArraySize&
  DIM BobArray(ArraySize&)
  GET (0,0)-(BobRight,BobBottom),BobArray
  RETURN

RedrawPicture:
  CLS
  PUT (0,0),BobArray,PSET
  ERASE BobArray
  DrawBoundary
  GOSUB PrintStatus
  RETURN

PrintStatus:
  PrintCurrentXY
  GOSUB PrintToolStatus
  GOSUB PrintColorBar
  RETURN

PrintToolStatus:
  LOCATE StatusLine,24: PRINT SPACE$(10);
  LOCATE StatusLine,24: PRINT ToolName$(ToolMode);
  RETURN

PrintColorBar:
  COLOR CurrentColor
  LOCATE 19,1: PRINT "Color:";
  ColorBar = WINDOW(5)-10
  COLOR 1
  x=70
  FOR i=0 TO maxColor
    LINE (x,ColorBar)-(x+20,y+ColorBar+10),i,bf
    LINE (x,ColorBar)-(x+20,y+ColorBar+10),1,b
    x=x+20
  NEXT i
  RETURN

CheckColor:
  IF CurrentY<ColorBar OR CurrentY>ColorBar+10 THEN RETURN
  IF CurrentX<70 THEN RETURN
  i=INT((CurrentX-70)/20)
  IF i>maxColor THEN RETURN
  CurrentColor=i
  GOSUB PrintColorBar
  RETURN

CheckSave:
  IF fEnlarge THEN GOSUB Shrink
  CancelCommand=0
  IF Change THEN
    BEEP
    GOSUB GetPicture
    CLS
    PRINT "Current file is not saved."
    PRINT "Do you want to save it?"
    PRINT " Press Y key if you want to save it"
    PRINT " Press N key if don't you want to save it"
    PRINT " Press C key if you want to cancel command"
    Response=0
    WHILE Response=0
      a$=INPUT$(1)
        IF a$=="Y" THEN Response=1
        IF a$=="N" THEN Response=2
        IF a$=="C" THEN Response=3
        IF Response=0 THEN BEEP
    WEND
    GOSUB RedrawPicture
    IF Response=1 THEN GOSUB SaveFileAs
    IF Response=3 THEN CancelCommand=-1
  END IF
  RETURN

SUB GetCurrentXY STATIC
  SHARED CurrentX,CurrentY,InsideBob,BobRight,BobBottom
  dummy=MOUSE(0)
  CurrentX=MOUSE(1)
  CurrentY=MOUSE(2)
  InsideBob=-1
  IF CurrentX>BobRight OR CurrentY>BobBottom THEN InsideBob=0
  IF CurrentX<0 OR CurrentY<0 THEN InsideBob=0
  END SUB

SUB PrintCurrentXY STATIC
  SHARED StatusLine,CurrentX,CurrentY
  LOCATE StatusLine,1: PRINT "Bob size X:";CurrentX;
  LOCATE StatusLine,17: PRINT "Y:";CurrentY;
END SUB

SUB DrawBoundary STATIC
SHARED BobRight,BobBottom
  x=BobRight+10
  y=BobBottom+10
  LINE (0,y)-(x,y)
  LINE (x,y)-(x,0)
  LINE (0,BobBottom+1)-(x,BobBottom+1)
  LINE (BobRight+1,y)-(BobRight+1,0)
END SUB

SUB InvertVideo STATIC
   COLOR ,,3
END SUB

SUB NormalVideo STATIC
   COLOR ,,1
END SUB

SUB FrameRect(rect()) STATIC
  LINE (rect(1),rect(0))-(rect(3),rect(0))
  LINE (rect(3),rect(0))-(rect(3),rect(2))
  LINE (rect(3),rect(2))-(rect(1),rect(2))
  LINE (rect(1),rect(2))-(rect(1),rect(0))
END SUB